Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue28/amclock/AMCLOCK.ZIP/AMClock.pas

Pascal/Delphi Source File | 1997-10-13 | 17.5 KB | 656 lines

{ TAMClock version 1.0 for Delphi 2.x and 3.x
  Copyright ⌐ October 1997 by Alexander Meeder

  This analog clock is highly configurable. You can use a picture as the face of
  the clock (*.bmp, *.ico, *.emf and *.wmf). You can also configure the
  hour-, minute- and secondhand (backradius, radius, width, color). Additional
  you can set the interval (of the thread, no timer is used with this clock), the
  Priority and the center of the clock. This clock also has several events to
  trigger hour, minute and second events and a global timer event (every interval).

  TCenter properties (see also Center and AutoCenter properties of TAMClock)
    X  : default 50 except when Autocenter
    Y  : default 50    "     "      "

  THand properties (see also Hours-, Minutes- and SecondsHand properties of TAMClock)
    BackRadius : backradius of the hour, minute or second hand
    Color      : color      of  "    "      "    "    "     "
    Radius     : radius     of  "    "      "    "    "     "
    Width      : width      of  "    "      "    "    "     "

  TAMClock properties
    AutoCenter       : default True, centers clock on canvas
    Center           : TCenter-object with X,Y value
    HoursHand        : THand-object see description above
    Interval         : Update interval (and interval of OnTimer-event)
    Interactive      : default False, when true you can click at runtime on clock
                       to move the center
    MinutesHand      : THand-object see description above
    Picture          : default SAMPLECLOCK.BMP, every *.bmp, *.emf, *.ico or
                       *.wmf-file
    Priority         : default tpNormal, Thread priority (tpNormal, tpHight etc.)
    SecondsHand      : THand-object see description above
    Transparent      : default True
    TransparentColor : default clOlive, the picture-color to replace with the color
                       property of this component (default the form, panel etc.
                       color)

  TAMClocl events
    OnHour        : every hour
    OnMinute      : every minute
    OnSecond      : every second
    OnTimer       : triggered every X milisecond (X = interval property),
                    just like in Delphi's TTimer-object

    OnMouseEnter  : when the mouse enters the control
    OnMouseLeave  : when the mouse leaves the control
}

unit AMClock;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;

type
  TCmMouseEnter = record
    Msg    : Cardinal;
    Unused : Integer;
    Sender : TControl;
    Result : LongInt;
  end;
  TCmMouseLeave = TCmMouseEnter;

  TMouseEnterLeave = procedure (Sender: TObject) of object;

  THour   = procedure (Sender: TObject; Hour: word) of object;
  TMinute = procedure (Sender: TObject; Minute: word) of object;
  TSecond = procedure (Sender: TObject; Second: word) of object;

  TAMClock = class;
  TThrdTimer = class;

  TTimerThread = class(TThread)
    OwnerTimer: TThrdTimer;
    procedure Execute; override;
  end;

  TThrdTimer = class(TComponent)
  private
    FEnabled: boolean;
    FInterval: word;
    FOnTimer: TNotifyEvent;
    FTimerThread: TTimerThread;
    FThreadPriority: TThreadPriority;

    procedure SetEnabled(Value: Boolean);
    procedure SetInterval(Value: word);
    procedure SetThreadPriority(Value: TThreadPriority);
    procedure Timer; dynamic;
  protected
    procedure UpdateTimer;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property TimerThread: TTimerThread read FTimerThread write FTimerThread;
  published
    property Enabled: boolean read FEnabled write SetEnabled default True;
    property Interval: word read FInterval write SetInterval default 250;
    property Priority: TThreadPriority read FThreadPriority write SetThreadPriority default tpNormal;
    property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
  end;

  TCenter = class(TPersistent)
  private
    FX: integer;
    FY: integer;
    FParent: TAMClock;

    procedure SetCenter(Index, Value: integer);
  protected
    procedure UpdateParent;
  public
    constructor Create;
    property Parent: TAMClock read FParent write FParent;
  published
    property X: integer index 0 read FX write SetCenter default 50;
    property Y: integer index 1 read FY write SetCenter default 50;
  end;

  THand = class(TPersistent)
  private
    FBackRadius: integer;
    FColor: TColor;
    FParent: TAMClock;
    FRadius: integer;
    FWidth: integer;

    procedure SetBackRadius(Value: integer);
    procedure SetColor(Value: TColor);
    procedure SetRadius(Value: integer);
    procedure SetWidth(Value: integer);
  protected
    procedure UpdateParent;
  public
    constructor Create;
    property Parent: TAMClock read FParent write FParent;
  published
    property BackRadius: integer read FBackRadius write SetBackRadius default 10;
    property Color: TColor read FColor write SetColor default clRed;
    property Radius: integer read FRadius write SetRadius default 90;
    property Width: integer read FWidth write SetWidth default 2;
  end;

  TAMClock = class(TCustomControl)
  private
    FAutoCenter: boolean;
    FCenter: TCenter;
    FHoursHand: THand;
    FInteractive: boolean;
    FInterval: word;
    FMinutesHand: THand;
    FSecondsHand: THand;
    FPicture: TPicture;
    FPriority: TThreadPriority;
    FTransparent: boolean;
    FTransparentColor: TColor;

    FHour: THour;
    FMinute: TMinute;
    FSecond: TSecond;
    FOnTimer: TNotifyEvent;
    FMouseEnter : TMouseEnterLeave;
    FMouseLeave : TMouseEnterLeave;

    Timer: TThrdTimer;
    Buffer: TBitmap;
    h,m,s: word;
    OldHour, OldMinute, OldSecond: word;

    procedure SetAutoCenter(Value: boolean);
    procedure SetInterval(Value: word);
    procedure SetPicture(Value: TPicture);
    function  GetPriority: TThreadPriority;
    procedure SetPriority(Value: TThreadPriority);
    procedure SetTransparent(Value: boolean);
    procedure SetTransparentColor(Value: TColor);
  protected
    procedure UpdateClock(Sender: TObject);
    procedure DrawHand(XCenter, YCenter, Radius, BackRadius, HandWidth: integer; HandColor: TColor; Angle: Real);
    procedure CmEnabledChanged(var Message: TWmNoParams); message CM_ENABLEDCHANGED;
    procedure CmMouseEnter(var Message: TCmMouseEnter); message CM_MOUSEENTER;
    procedure CmMouseLeave(var Message: TCmMouseLeave); message CM_MOUSELEAVE;
    procedure CmVisibleChanged(var Message: TWmNoParams); message CM_VISIBLECHANGED;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Loaded; override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas;
  published
    property AutoCenter: boolean read FAutoCenter write SetAutoCenter default True;
    property Center: TCenter read FCenter write FCenter;
    property Color;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Hint;
    property HoursHand: THand read FHoursHand write FHoursHand;
    property Interval: word read FInterval write SetInterval default 250;
    property Interactive: boolean read FInteractive write FInteractive default False;
    property MinutesHand: THand read FMinutesHand write FMinutesHand;
    property ParentColor;
    property ParentShowHint;
    property Picture: TPicture read FPicture write SetPicture;
    property PopupMenu;
    property Priority: TThreadPriority read GetPriority write SetPriority default tpNormal;
    property SecondsHand: THand read FSecondsHand write FSecondsHand;
    property ShowHint;
    property Transparent: boolean read FTransparent write SetTransparent default True;
    property TransparentColor: TColor read FTransparentColor write SetTransparentColor default clOlive;
    property Visible;
    property OnClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnHour: THour read FHour write FHour;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMinute: TMinute read FMinute write FMinute;
    property OnMouseDown;
    property OnMouseEnter : TMouseEnterLeave read FMouseEnter write FMouseEnter;
    property OnMouseLeave : TMouseEnterLeave read FMouseLeave write FMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnSecond: TSecond read FSecond write FSecond;
    property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
    property OnStartDrag;
  end;

procedure Register;

implementation

{$R AMClock.res}

procedure TAMClock.UpdateClock(Sender: TObject);
var
  hsec: word;
begin
  DecodeTime(Time,h,m,s,hsec);
  Repaint;
  if s <> OldSecond then
  begin
    if Assigned(FSecond) then FSecond(Self, s);
    OldSecond := s;
  end;
  if m <> OldMinute then
  begin
    if Assigned(FMinute) then FMinute(Self, m);
    OldMinute := m;
  end;
  if h <> OldHour then
  begin
    if Assigned(FHour) then FHour(Self, h);
    OldHour := h;
  end;
  if Assigned(FOnTimer) then FOnTimer(Self);
end;

procedure TAMClock.Paint;
var
  Angle: real;
begin
  Buffer.Width := Self.Width;
  Buffer.Height := Self.Height;
  with Buffer.Canvas do
  begin
    Brush.Color := Self.Color;
    Brush.Style := bsSolid;
    Pen.Color := Self.Color;
    Rectangle(0,0,Width,Height);
    if FTransparent then
       BrushCopy(ClientRect, FPicture.Bitmap, ClientRect, FTransparentColor)
    else
       Draw(0,0,FPicture.Graphic);
  end;

  Angle := 2 * PI * (h + m / 60) / 12;
  DrawHand(100,100,HoursHand.Radius,HoursHand.BackRadius,HoursHand.Width,HoursHand.Color,Angle);
  Angle := 2 * PI * m / 60;
  DrawHand(100,100,MinutesHand.Radius,MinutesHand.BackRadius,MinutesHand.Width,MinutesHand.Color,Angle);
  Angle := 2 * PI * s / 60;
  DrawHand(100,100,SecondsHand.Radius,SecondsHand.BackRadius,SecondsHand.Width,SecondsHand.Color,Angle);

  Canvas.Draw(0,0,Buffer);
end;

procedure TAMClock.Loaded;
var
  HSec: word;
begin
  inherited Loaded;
  Buffer.Width := Self.ClientWidth;
  Buffer.Height := Self.ClientHeight;
  Buffer.Canvas.Brush.Color := Color;
  if AutoCenter then
  begin
    with Center do
    begin
      X := Width div 2;
      Y := Height div 2;
    end;
  end;
  DecodeTime(Now, OldHour, OldMinute, OldSecond, HSec);
end;

procedure TAMClock.SetAutoCenter(Value: boolean);
begin
  if Value <> FAutoCenter then
  begin
    if Value then
    begin
      with FCenter do
      begin
        X := Width div 2;
        Y := Height div 2;
      end;
    end;
    FAutoCenter := Value;
    Repaint;
  end;
end;

procedure TAMClock.SetInterval(Value: word);
begin
  if Value <> FInterval then
  begin
    FInterval := Value;
    Timer.Interval := FInterval;
    Repaint;
  end;
end;

procedure TAMClock.SetPicture(Value: TPicture);
begin
  if Transparent and not (Value.Graphic is TBitmap) then Transparent := False;
  FPicture.Assign(value);
  Width := FPicture.Width;
  Buffer.Width := Width;
  Height := FPicture.Height;
  Buffer.Height := Height;
  if AutoCenter then
  begin
    with Center do
    begin
      X := Width div 2;
      Y := Height div 2;
    end;
  end;
  Repaint;
end;

function TAMClock.GetPriority: TThreadPriority;
begin
  Result := Timer.Priority;
end;

procedure TAMClock.SetPriority(Value: TThreadPriority);
begin
  if Value <> FPriority then
  begin
    FPriority := Value;
    Timer.Priority := FPriority;
  end;
end;

procedure TAMClock.SetTransparent(Value: boolean);
begin
  if FPicture.Graphic is TBitmap then
    if Value <> FTransparent then
    begin
      FTransparent := Value;
      FTransparentColor := FPicture.Bitmap.Canvas.Pixels[0,FPicture.Bitmap.Height-1];
      Repaint;
    end
  else
    FTransparent := False;
end;

procedure TAMClock.SetTransparentColor(Value: TColor);
begin
  if Value <> FTransparentColor then
  begin
    FTransparentColor := Value;
    if (Value <> clNone) and not Transparent then FTransparent := True;
    Repaint;
  end;
end;

procedure TAMClock.DrawHand(XCenter, YCenter, Radius, BackRadius, HandWidth: integer; HandColor: TColor; Angle: Real);
var
  X,Y: integer;
begin
  with Buffer.Canvas.Pen do
  begin
    Width := HandWidth;
    Color := HandColor;
  end;
  with Buffer.Canvas do
  begin
    Angle := (Angle + 3 * PI / 2);
    X := Center.X - Round(BackRadius * cos(Angle));
    Y := Center.Y - Round(BackRadius * sin(Angle));
    MoveTo(Center.X,Center.Y);
    LineTo(X,Y);
    X := Center.X + Round(Radius * cos(Angle));
    Y := Center.Y + Round(Radius * sin(Angle));
    MoveTo(Center.X,Center.Y);
    LineTo(X,Y);
  end;
end;

procedure TAMClock.CmEnabledChanged(var Message: TWmNoParams);
begin
  inherited;
  Timer.Enabled := Self.Enabled;
  Repaint;
end;

procedure TAMClock.CmMouseEnter(var Message: TCmMouseEnter);
begin
  inherited;
  if Assigned(FMouseEnter) then FMouseEnter(Self);
end;

procedure TAMClock.CmMouseLeave(var Message: TCmMouseLeave);
begin
  inherited;
  if Assigned(FMouseLeave) then FMouseLeave(Self);
end;

procedure TAMClock.CmVisibleChanged(var Message: TWmNoParams);
begin
  inherited;
  Repaint;
end;

procedure TAMClock.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if (Button = mbLeft) and Interactive then
  begin
    Center.X := X;
    Center.Y := Y;
  end;
  inherited MouseDown(Button, Shift, X, Y);
end;

constructor TAMClock.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  SetBounds(0,0,100,100);
  FInterval := 250;
  Timer := TThrdTimer.Create(self);
  Timer.Interval := FInterval;
  Timer.OnTimer := UpdateClock;
  Buffer := TBitmap.Create;
  FPicture := TPicture.Create;
  FPicture.Bitmap.Handle := LoadBitmap(hInstance, 'SAMPLECLOCK');
  FPriority := tpNormal;
  FSecondsHand := THand.Create;
  with FSecondsHand do
  begin
    Parent := Self;
    BackRadius := 10;
    Color := clRed;
    Radius := 48;
    Width := 1;
  end;
  FMinutesHand := THand.Create;
  with FMinutesHand do
  begin
    Parent := Self;
    BackRadius := 0;
    Color := clBlack;
    Radius := FSecondsHand.Radius * 90 div 100;
    Width := 2;
  end;
  FHoursHand := THand.Create;
  with FHoursHand do
  begin
    Parent := Self;
    BackRadius := 0;
    Color := clBlack;
    Radius := FSecondsHand.Radius * 70 div 100;
    Width := 2;
  end;
  FCenter := TCenter.Create;
  FCenter.Parent := Self;
  FAutoCenter := True;
  FInteractive := False;
  FTransparent := True;
  FTransparentColor := clOlive;
end;

destructor TAMClock.Destroy;
begin
  FPicture.Free;
  Buffer.Free;
  Timer.Free;
  inherited Destroy;
end;

// Begin of TThrdTimer-implementation...
procedure TTimerThread.Execute;
begin
  Priority := OwnerTimer.Priority;
  repeat
    SleepEx(OwnerTimer.Interval, False);
    Synchronize(OwnerTimer.Timer);
  until Terminated;
end;

procedure TThrdTimer.UpdateTimer;
begin
  if not TimerThread.Suspended then TimerThread.Suspend;
  if (FInterval <> 0) and FEnabled then
     if TimerThread.Suspended then TimerThread.Resume;
end;

procedure TThrdTimer.SetEnabled(Value: boolean);
begin
  if Value <> FEnabled then
  begin
    FEnabled := Value;
    UpdateTimer;
  end;
end;

procedure TThrdTimer.SetInterval(Value: Word);
begin
  if Value <> FInterval then
  begin
    FInterval := Value;
    UpdateTimer;
  end;
end;

procedure TThrdTimer.SetThreadPriority(Value: TThreadPriority);
begin
  if Value <> FThreadPriority then
  begin
    FThreadPriority := Value;
    UpdateTimer;
  end;
end;

procedure TThrdTimer.Timer;
begin
  if Assigned(FOntimer) then FOnTimer(Self);
end;

constructor TThrdTimer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEnabled := True;
  FInterval := 250;
  FThreadPriority := tpNormal;
  FTimerThread := TTimerThread.Create(False);
  FTimerThread.OwnerTimer := Self;
end;

destructor TThrdTimer.Destroy;
begin
  FEnabled := False;
  UpdateTimer;
  FTimerThread.Free;
  inherited Destroy;
end;

// Begin of THand-implementation...
procedure THand.SetBackRadius(Value: integer);
begin
  if Value <> FBackRadius then
  begin
    FBackRadius := Value;
    UpdateParent;
  end;
end;

procedure THand.SetColor(Value: TColor);
begin
  if Value <> FColor then
  begin
    FColor := Value;
    UpdateParent;
  end;
end;

procedure THand.SetRadius(Value: integer);
begin
  if Value <> FRadius then
  begin
    FRadius := Value;
    UpdateParent;
  end;
end;

procedure THand.SetWidth(Value: integer);
begin
  if Value <> FWidth then
  begin
    FWidth := Value;
    UpdateParent;
  end;
end;

procedure THand.UpdateParent;
begin
  Parent.Repaint;
end;

constructor THand.Create;
begin
  inherited Create;
  FBackRadius := 10;
  FColor := clRed;
  FRadius := 90;
  FWidth := 2;
end;

procedure TCenter.SetCenter(Index, Value: integer);
begin
  case Index of
    0: if Value <> FX then FX := Value;
    1: if Value <> FY then FY := Value;
  end;
  if Parent.AutoCenter then Parent.AutoCenter := False;
  UpdateParent;
end;

procedure TCenter.UpdateParent;
begin
  Parent.Repaint;
end;

constructor TCenter.Create;
begin
  inherited Create;
  FX := 50;
  FY := 50;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TAMClock]);
end;

end.